home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / unix_float.t < prev    next >
Text File  |  1988-02-05  |  4KB  |  155 lines
  1. (herald unix_float (env tsys))
  2.  
  3. (define-integrable (make-flonum)
  4.   (make-vector-extend header/double-float 0 2 ))
  5.  
  6. (define (kludgy-string->flonum s)
  7.   (let ((n (make-flonum))
  8.         (b (get-string-buffer-of-size 50)))
  9.     (set (string-length b) 50)
  10.     (string-fill b #\space)
  11.     (string-replace b s (string-length s))
  12.     (sscanf b "%F" n)
  13.     (release-string-buffer b)
  14.     n))
  15.  
  16. (define-foreign sscanf (sscanf (in rep/string)
  17.                                (in rep/string)
  18.                                (in rep/extend))   ; pointer to double
  19.   rep/undefined)
  20.                                                
  21. (define (print-flonum-kludgily n stream)
  22.   (let ((b (get-string-buffer-of-size 50)))       
  23.     (set (string-length b) 50)
  24.     (sprintf b "%e!" n)
  25.     (set (string-length b) (string-posq #\! b))
  26.     (write-string stream b)
  27.     (release-string-buffer b)
  28.     (no-value)))
  29.  
  30. (define-foreign sprintf (sprintf (in rep/string)
  31.                                  (in rep/string)
  32.                                  (in rep/double))
  33.   rep/undefined)
  34.  
  35. (define (*define-fl-proc-1 xenoid id)
  36.   (object (lambda (x)
  37.             (xenoid (enforce double-float? x)))
  38.           ((identification self) id)))
  39.  
  40. (define (*define-fl-proc-3 xenoid id)
  41.   (object (lambda (x y)
  42.             (let ((x (enforce double-float? x))
  43.                   (y (enforce double-float? y)))
  44.               (fixnum-odd? (xenoid x y))))
  45.           ((identification self) id)))
  46.                     
  47. (define-local-syntax (define-fl-proc-1 name)
  48.   (let ((xeno-name (concatenate-symbol 'fl name)))
  49.     `(block (define-foreign ,xeno-name (,name (in rep/double))
  50.               rep/double)
  51.             (define ,name (*define-fl-proc-1 ,xeno-name ',name)))))
  52.   
  53.  
  54. (define-local-syntax (define-fl-proc-3 name)
  55.   (let ((xeno-name (concatenate-symbol 'fl name))
  56.         (t-name (concatenate-symbol 'flonum- name '?)))
  57.     `(block (define-foreign ,xeno-name 
  58.               (,xeno-name (in rep/double)
  59.                           (in rep/double))
  60.               rep/integer)
  61.             (define ,t-name (*define-fl-proc-3 ,xeno-name ',t-name)))))
  62.   
  63. (define-foreign %flonum-add (fladd (in rep/extend) (in rep/extend) (in rep/extend))
  64.   ignore)
  65.  
  66. (define-foreign %flonum-subtract (flsubtract (in rep/extend) (in rep/extend) (in rep/extend))
  67.   ignore)
  68.  
  69. (define-foreign %flonum-multiply (flmultiply (in rep/extend) (in rep/extend) (in rep/extend))
  70.   ignore)
  71.  
  72. (define-foreign %flonum-divide (fldivide (in rep/extend) (in rep/extend) (in rep/extend))
  73.   ignore)
  74.  
  75. (define (make-flonum-binop proc)
  76.   (lambda (x y)
  77.     (let ((x (enforce double-float? x))
  78.       (y (enforce double-float? y))
  79.       (z (make-flonum)))
  80.       (proc z x y)
  81.       z)))
  82.  
  83. (define flonum-add  (make-flonum-binop %flonum-add))
  84. (define flonum-subtract  (make-flonum-binop %flonum-subtract))
  85. (define flonum-multiply  (make-flonum-binop %flonum-multiply))
  86. (define flonum-divide  (make-flonum-binop %flonum-divide))
  87.  
  88. (define (fl+! x y)
  89.   (%flonum-add x x y)
  90.   x)
  91.  
  92. (define (fl-! x y)
  93.   (%flonum-subtract x x y)
  94.   x)
  95.  
  96.  
  97. (define (fl*! x y)
  98.   (%flonum-multiply x x y)
  99.   x)
  100.  
  101.  
  102. (define (fl/! x y)
  103.   (%flonum-divide x x y)
  104.   x)
  105.  
  106.  
  107. (define-fl-proc-1 sin)
  108. (define-fl-proc-1 cos)
  109. (define-fl-proc-1 tan)
  110. (define-fl-proc-1 asin)
  111. (define-fl-proc-1 acos)
  112. (define-fl-proc-1 atan)
  113. (define-fl-proc-1 exp)
  114. (define-fl-proc-1 log)
  115. (define-fl-proc-1 sqrt)
  116.  
  117.  
  118. ;;; ... also need power and atan2
  119.  
  120. (define-fl-proc-3 less)
  121. (define-fl-proc-3 equal)
  122. (define-fl-proc-3 greater)
  123.  
  124.  
  125. (define (flonum-not-equal? a b) (not (flonum-equal? a b)))
  126. (define (flonum-not-less? a b) (not (flonum-less? a b)))
  127. (define (flonum-not-greater? a b) (not (flonum-greater? a b)))
  128.                  
  129. (define-foreign float 
  130.   (flote (in rep/integer))   ; losing C reserved words
  131.     rep/double)
  132.  
  133. (define (fixnum->flonum fx)
  134.   (float (enforce fixnum? fx)))
  135.            
  136. (define-foreign fix
  137.   (fix (in rep/double))
  138.     rep/integer)
  139.  
  140. (define (flonum->fixnum fl)
  141.   (fix (enforce double-float? fl)))
  142.  
  143. (define-constant fl+  flonum-add)
  144. (define-constant fl-  flonum-subtract)
  145. (define-constant fl*  flonum-multiply)
  146. (define-constant fl/  flonum-divide)
  147. (define-constant fl=  flonum-equal?)
  148. (define-constant fl<  flonum-less?)
  149. (define-constant fl>  flonum-greater?)
  150. (define-constant fln= flonum-not-equal?)
  151. (define-constant fl>= flonum-not-less?)
  152. (define-constant fl<= flonum-not-greater?)
  153.  
  154.  
  155.